home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / inliner.zip / INLINER.PAS < prev   
Pascal/Delphi Source File  |  1990-05-17  |  52KB  |  1,595 lines
  1. {                                Inliner
  2.  
  3.     Version 1.00                                     File: INLINER.PAS
  4. Last revised: 12 Apr 1985                          Author: Anthony M. Marcy
  5.  
  6. DESCRIPTION
  7.  
  8.    Inliner is an assembler which translates 8088 assembly language directly
  9. into Turbo Pascal INLINE code.  It is written in, and generates code for,
  10. Turbo Pascal 2.00 for the IBM PC.  This program is in the public domain.
  11.    Inliner accepts a source language similar, but not identical, to that
  12. of the IBM Macro Assembler (MASM).  It produces a single Turbo INLINE statement
  13. ready to be merged into a Pascal program or used as an Include file.
  14.    All 8088 instructions are supported.  MASM pseudo-ops are not, and there
  15. are a few differences in syntax between Inliner and MASM, as detailed below.
  16.    System requirements are those for running Turbo.  If you can compile
  17. Inliner, you can run it.  (If you can't compile it, you don't need it.)
  18. Maximum assembly program size is set by the size of memory.  Inliner can use
  19. all available contiguous memory.
  20.    The new version 3.00 of Turbo has changes to the INLINE statement which
  21. make it not always compatible with code written for Turbo 2.00.  Inliner 1.00
  22. is designed to work with Turbo 2.00.  In particular, assembly programs which
  23. contain both labels and constant identifiers, and assembled by Inliner, may
  24. not compile correctly under Turbo 3.00.
  25.  
  26. GETTING STARTED
  27.  
  28.    You will be prompted for a source file and a target file.  If no source
  29. filename extension is given, .ASM is assumed.  The default target file is
  30. your source filename with extension .PAS; a carriage return accepts the
  31. default, or you may enter any legal filename.
  32.    Quick trick: entering TRM: as the source file will allow you to type your
  33. input directly into Inliner.  It will not be saved, however, and no editing
  34. is available.  End your input with ctrl-z.  Entering NUL as the target file
  35. will cause no output file to be generated, but you can still see the output
  36. on the screen.  Handy if you just need a line or two, or for testing what
  37. will "work".
  38.    Inliner may also be started from the DOS command line, thus:
  39.                 A> inliner infile.asm outfile.pas
  40. The second parameter may be omitted, in which case the default is assumed.
  41.  
  42.  
  43. INSTRUCTION FORMAT
  44.  
  45.    An Inliner source line takes the general form:
  46.                label: opcode operand, operand ;comment
  47. Each of these components is optional.
  48.  
  49.    A LABEL can be anything that would be legal as a Turbo identifier, limited
  50. in length to a maximum of twenty characters.  The colon is mandatory after
  51. a label.
  52.  
  53.    OPCODEs are the standard Intel mnemonics.  LOCK and the various REP
  54. prefixes are supported.  The segment override prefix can only be placed before
  55. an operand, not before the opcode.
  56.  
  57.    OPERANDs can be of three general kinds: register, address, and immediate.
  58. Register operands are the usual mnemonics - AX,BX, etc.
  59. Address operands have the following form:
  60.                prefix: (type) [base] [index] offset
  61. Each component is optional.  The ordering is strict.
  62.        prefix is a segment override -- DS, CS, SS, or ES
  63.        type is a single letter --  N   Near
  64.                                    F   Far
  65.                                    S   Short
  66.                                    W   Word
  67.                                    B   Byte
  68.        base is a base register -- BX or BP
  69.        index is an index register -- SI or DI
  70.        offset is either a literal constant or a Turbo identifier
  71.  
  72. Turbo identifiers are copied into the INLINE code.  Any identifier which does
  73. not occur as a label is assumed to be a Turbo identifier. The compiler replaces
  74. variable names with their offsets within their segments; it replaces constant
  75. identifiers with their values.  The location counter, *, is also legal.  See
  76. the Turbo manual for details.
  77.      ADD AL,var1     ;var1 is a global variable in the data segment
  78.      ADD AL,[BP]var2 ;var2 is a local variable in the stack segment
  79.      ADD AL,CS:var3  ;var3 is a typed constant in the code segment
  80.  
  81. Immediate operands are distinguished by being prefixed with an equal sign.
  82. They may be constants or Turbo variables.  Thus,
  83.      MOV AX,=2 ;loads the value 2 into AX
  84.      MOV AX,2  ;loads AX with the word at offset 2 in the data segment
  85.      MOV AX,var1  ;loads AX with the contents of variable var1
  86.      MOV AX,=var1 ;loads the offset of variable var1 into AX
  87. The equal sign is optional in the INT, RET, IN, and OUT instructions, and
  88. before character literals.
  89.  
  90.    CONSTANTs can be decimal integers (positive or negative), hex constants
  91. in Turbo format (preceded by $), constant identifers, or character literals
  92. enclosed in single quotes.  Examples:  2   -128   $FF   cons   'x'
  93.    The type must be specified when it cannot otherwise be deduced:
  94.      ADD AX,[BP]2  ;AX - must be a word operand
  95.      INC (W)[BP]2  ;requires (W) or (B)
  96. Immediate numeric constants default to (B)yte if in the range -128..255,
  97. otherwise (W)ord.
  98.  
  99.    JMP requires special treatment.  A (F)ar jump to an absolute address may be
  100. coded with two operands, both immediate constants, representing the segment
  101. and the offset:
  102.      JMP =$0060,=$0100   ;absolute address 0060:0100
  103. A (N)ear jump to an offset in the CS requires a single immediate operand:
  104.      JMP =$0100   ;address CS:0100
  105.      JMP =*-1   ;this instruction jumps to itself
  106. An indirect jump takes either a register or an address operand.  In the latter
  107. case, the type must be specified:
  108.      JMP AX     ;must be (N)ear
  109.      JMP (F)[BP][SI]
  110.      JMP (N)var1
  111. Lastly, the jump target may be an Inliner label.  For forward references,
  112. more efficient code can be generated if (S)hort is specified when possible:
  113.      JMP lab1
  114.      JMP (S)lab2
  115.  
  116.    CALL is similar to JMP, except that (S)hort cannot be used.
  117.  
  118.    The conditional jump instructions -- JE, JNE, etc. -- take a single
  119. operand which may be either an immediate constant in the range -128..127
  120. or an Inliner label.
  121.  
  122.    The string instructions vary slightly from MASM syntax.  REP, REPZ, etc.,
  123. are considered prefixes which must be placed before a string opcode on the
  124. same line.  The special no-operand forms of the string opcodes -- MOVSB,
  125. MOVSW, etc. -- are not implemented.  Instead, use the basic opcode with
  126. a type specifier.  The full two-operand forms may also be written.
  127.      REP CMPS (B)
  128.      REP MOVS (W)[SI],[DI]
  129.  
  130.    Other instructions resemble their counterparts in MASM.  Refer to the
  131. Macro Assembler manual for their formats.  Inliner does not support any
  132. pseudo-ops, such as PROC, END, DW, or ASSUME.  Nor does it support the
  133. 8087 mnemonics.
  134.    Pascal declarations should be used to define data, in place of DB, DW,
  135. EQU, etc.  But remember that your variables are Turbo variables -- Inliner
  136. cannot see your declarations to check type or addressibility.  You must
  137. provide segment overrides where needed.
  138.  
  139.  
  140. EXAMPLES
  141.  
  142.    Here are some more examples of Inliner code:
  143.  
  144.      PUSH BP
  145.  h2: CMP var1,=-1    ;byte variable assumed
  146.      CMP var1,(W)=-1  ;unless overridden
  147.      MOV var2,=var4  ;address is always two bytes
  148.      JE (S)h5
  149.      REPE SCAS(B) ;instead of SCASB
  150.      shl ax,cl   ;lower case is OK
  151.      ESC = 23 , [ DI ] var2 ;spaces are OK, too
  152.      MOV ES:4,'&'
  153.  h5: SUB (W)var3,=$40
  154.      NOP
  155.      CALL (N)xyz ;indirect through variable xyz
  156.                  ;unless xyz is a label
  157.      MOV [BX][DI],CS
  158.      RET (N) 4   ;(N) or (F) required
  159.  
  160.      -----------------------------------------------------------------
  161.  
  162.    Inliner is supported on the RBBS-PC operated by
  163.               James Miles
  164.               "The Programmer's Toolbox"
  165.               (301) 540-7230 (data)
  166.               24 Hrs.
  167. Comments, bug reports, and suggested improvements are encouraged.  Address
  168. them to ANTHONY MARCY or to SYSOP.  If you make extensions or revisions
  169. to this program, please upload so that all may share.
  170.  
  171.                              Enjoy!
  172.  
  173.      -----------------------------------------------------------------}
  174.  
  175.  
  176. program inliner;
  177.  
  178. const
  179.   tsize = 200;     { size of symbol table }
  180.  
  181. type
  182.   filename = string[20];
  183.   opcode = (nul,
  184.             mov,push,pop,xchg,in_,out,xlat,lea,lds,les,lahf,sahf,pushf,
  185.             popf,add,adc,inc,sub,sbb,dec,neg,cmp,aas,das,mul,imul,aam,div_,
  186.             idiv,aad,cbw,cwd,not_,shl_,sal,shr_,sar,rol,ror,rcl,rcr,and_,
  187.             test_,or_,xor_,aaa,daa,rep,repe,repz,repne,repnz,movs,cmps,scas,
  188.             lods,stos,call,jmp,ret,je,jz,jl,jnge,jle,jng,jb,jnae,jbe,jna,jp,
  189.             jpe,jo,js,jne,jnz,jnl,jge,jnle,jg,jnb,jae,jnbe,ja,jnp,jpo,jno,jns,
  190.             loop,loopz,loope,loopnz,loopne,jcxz,int,into,iret,
  191.             clc,cmc,stc,cld,std,cli,sti,hlt,wait,esc,lock,nop,
  192.             valid,
  193.             assume,comment,db,dd,dq,dt,dw,end_,equ,even,extrn,group,include,
  194.             label_,name,org,proc,public,record_,segment,struc,macro,endm,
  195.             page,subttl,title,
  196.             fld,fst,fstp,fxch,fcom,fcomp,fcompp,ftst,fxam,fadd,fsub,fmul,fdiv,
  197.             fsqrt,fscale,fprem,frndint,fxtract,fabs,fchs,fptan,fpatan,f2xm1,
  198.             fyl2x,fyl2xp1,fldz,fld1,fldpi,fldl2t,fldl2e,fldlg2,fldln2,finit,
  199.             feni,fdisi,fldcw,fstcw,fstsw,fclex,fstenv,fldenv,fsave,frstor,
  200.             fincstp,fdecstp,ffree,fnop,fwait,
  201.             last);
  202.   regs = (firstreg,ax,bx,cx,dx,sp,bp,si,di,al,bl,cl,dl,ah,bh,ch,dh,
  203.           ds,ss,cs,es,lastreg);
  204.   line = string[80];
  205.   idtype = string[20];
  206.   attr = record                   { attributes of an operand }
  207.            isop: boolean;
  208.            isaddr: boolean;
  209.            isid: boolean;
  210.            isconst: boolean;
  211.            value: integer;
  212.            isreg: boolean;
  213.            issreg: boolean;
  214.            rg: regs;
  215.            isimmed: boolean;
  216.            isidx,isbase: boolean;
  217.            idx,base: regs;
  218.            isbyte,isword: boolean;
  219.            isshort,isnear,isfar: boolean;
  220.            ident: idtype;
  221.          end;
  222.   cptr = ^codrec;
  223.   codrec = record                  { intermediate form of a line of code }
  224.              next: cptr;
  225.              labeln: integer;
  226.              op: opcode;
  227.              op1,op2: attr;
  228.              repx: opcode;
  229.              lockx: boolean;
  230.              override: regs;
  231.              source: line;
  232.              errn: byte;
  233.            end;
  234.   charset = set of char;
  235.  
  236. var
  237.   reg: array[regs] of string[2];             { register mnemonics }
  238.   rn: array[regs] of 0..7;                   { register numbers   }
  239.   mn: array[opcode] of string[6];            { opcode mnemonics   }
  240.   tab: array[0..tsize] of record             { symbol table }
  241.                             id: idtype;
  242.                             val: integer;
  243.                           end;
  244.   src,targ: text;                       { source and target files }
  245.   errn,pass: byte;                      { error #, pass # }
  246.   atstart,ok: boolean;
  247.   t: string[132];                       { target line }
  248.   loc: integer;          { location counter }
  249.   tcnt: integer;         { number of entries in symbol table }
  250.   n: integer;            { index into symbol table }
  251.   oldlen: integer;
  252.   firstentry: cptr;      { points to first line of intermediate code }
  253.   codpnt: cptr;          { points to current line of intermediate code }
  254.  
  255.   op: opcode;
  256.   op1,op2: attr;
  257.   repx: opcode;
  258.   lockx: boolean;
  259.   override: regs;
  260.  
  261.  
  262. procedure error(j: integer);    { only the first error in a line is recorded }
  263.  
  264. begin
  265.   if errn = 0 then errn := j;
  266. end;
  267.  
  268. procedure message;         { print error messages }
  269.  
  270. begin
  271.   if errn <> 0
  272.   then begin
  273.     ok := false;
  274.     t := t + '***';
  275.     case errn of
  276.      1: t := t + 'NOT ENOUGH OPERANDS';
  277.      2: t := t + 'INVALID OPERAND';
  278.      3: t := t + 'TYPE CONFLICT';
  279.      4: t := t + 'INVALID OPCODE';
  280.      5: t := t + 'INVALID REGISTER';
  281.      6: t := t + 'SYNTAX ERROR';
  282.      7: t := t + 'TYPE NOT SPECIFIED';
  283.      8: t := t + 'ILLEGAL REGISTER';
  284.      9: t := t + 'ERROR IN CONSTANT';
  285.     10: t := t + 'ILLEGAL OPERAND';
  286.     11: t := t + 'TOO MANY OPERANDS';
  287.     12: t := t + 'CONSTANT TOO BIG';
  288.     13: t := t + 'DUPLICATE PREFIX';
  289.     14: t := t + 'IDENTIFIER TOO LONG';
  290.     15: t := t + 'DUPLICATE LABEL';
  291.     16: t := t + 'UNDEFINED LABEL';
  292.     17: t := t + 'LABEL TOO FAR';
  293.     18: t := t + 'NOT IMPLEMENTED';
  294.   { 29: system error }
  295.  
  296.     else t := t + 'SYSTEM ERROR';
  297.     end;
  298.     t := t + '***'
  299.   end
  300. end;
  301.  
  302. function stupcase(st: idtype): idtype;
  303.  
  304. var i: integer;
  305.  
  306. begin
  307.   for i := 1 to length(st) do
  308.     st[i] := upcase(st[i]);
  309.   stupcase := st
  310. end;  { stupcase }
  311.  
  312. procedure startup;       { input names of source and target files }
  313.  
  314. var
  315.   exists: boolean;
  316.   inf,outf,tempstr: filename;
  317.   commandline: string[127] absolute cseg:$80;
  318.   params: string[127];
  319.   default: byte;
  320.  
  321.   procedure chkinf;             { does source file exist? }
  322.   begin
  323.     inf := stupcase(inf);
  324.     if pos('.',inf) = 0
  325.     then inf := inf + '.ASM';
  326.     assign(src,inf);
  327.     {$I-} reset(src) {$I+} ;            { if so, open it }
  328.     exists := (ioresult = 0);
  329.     if pos(':',inf) = 0
  330.     then inf := chr(default+65) + ':' + inf;
  331.     if not exists
  332.     then writeln('File ', inf, ' not found');
  333.   end;
  334.  
  335.   procedure chkoutf;               { is target filename valid? }
  336.   begin
  337.     outf := stupcase(outf);
  338.     assign(targ,outf);
  339.     {$I-} rewrite(targ) {$I+} ;         { if so, open it }
  340.     exists := (ioresult = 0);
  341.     if pos(':',outf) = 0
  342.     then outf := chr(default+65) + ':' + outf;
  343.     if not exists
  344.     then writeln('can''t open file ',outf);
  345.   end;
  346.  
  347. begin
  348.   inf := ''; outf := ''; params := commandline;
  349.   Inline(
  350.      $B4/$19                    { MOV AH,=$19 }
  351.     /$CD/$21                    { INT =$21    }
  352.     /$88/$86/default );         { MOV [BP]default,AL }
  353.   while (params <> '') and (params[1] = ' ') do
  354.     delete(params,1,1);
  355.   if params <> ''
  356.   then begin                                       { command line parameters }
  357.     while (params <> '') and (params[1] <> ' ') do begin
  358.       inf := inf + params[1];
  359.       delete(params,1,1); end;
  360.     chkinf;
  361.     if not exists then begin
  362.       commandline := '';
  363.       startup; end
  364.     else begin
  365.       writeln('Source file: ',inf);
  366.       while (params <> '') and (params[1] = ' ') do
  367.         delete(params,1,1);
  368.       if params <> ''
  369.       then while (params <> '') and (params[1] <> ' ') do begin
  370.         outf := outf + params[1];
  371.         delete(params,1,1); end
  372.       else outf := copy(inf,1,pos('.',inf)) + 'PAS';
  373.       chkoutf;
  374.       if not exists then begin
  375.         commandline := '';
  376.         startup; end
  377.       else writeln('Target file: ',outf);
  378.       end;
  379.     end
  380.   else begin                                        { prompt for filenames }
  381.     repeat
  382.       write('  Source file [.ASM] ? '); readln(inf);
  383.       chkinf;
  384.     until exists;
  385.     tempstr := copy(inf,1,pos('.',inf)) + 'PAS';
  386.     repeat
  387.       repeat
  388.         write('  Target file [',tempstr,'] ? ');
  389.         readln(outf); outf := stupcase(outf);
  390.       until inf <> outf;
  391.       if outf = '' then outf := tempstr;
  392.       chkoutf;
  393.     until exists;
  394.     end;
  395.   writeln;
  396. end;  { startup }
  397.  
  398. procedure init;               { initialize tables }
  399.  
  400. begin
  401.   mn[mov ] := 'MOV' ;   mn[push] := 'PUSH';   mn[pop ] := 'POP' ;
  402.   mn[xchg] := 'XCHG';   mn[in_ ] := 'IN'  ;   mn[out ] := 'OUT' ;
  403.   mn[xlat] := 'XLAT';   mn[lea ] := 'LEA' ;   mn[lds ] := 'LDS' ;
  404.   mn[les ] := 'LES' ;   mn[lahf] := 'LAHF';   mn[pushf] := 'PUSHF';
  405.   mn[sahf] := 'SAHF';   mn[popf] := 'POPF';   mn[add ] := 'ADD' ;
  406.   mn[adc ] := 'ADC' ;   mn[inc ] := 'INC' ;   mn[sub ] := 'SUB' ;
  407.   mn[sbb ] := 'SBB' ;   mn[dec ] := 'DEC' ;   mn[cmp ] := 'CMP' ;
  408.   mn[aas ] := 'AAS' ;   mn[das ] := 'DAS' ;   mn[mul ] := 'MUL' ;
  409.   mn[imul] := 'IMUL';   mn[aam ] := 'AAM' ;   mn[div_] := 'DIV' ;
  410.   mn[idiv] := 'IDIV';   mn[aad ] := 'AAD' ;   mn[cbw ] := 'CBW' ;
  411.   mn[cwd ] := 'CWD' ;   mn[aaa ] := 'AAA' ;   mn[daa ] := 'DAA' ;
  412.   mn[not_] := 'NOT' ;   mn[shl_] := 'SHL' ;   mn[sal ] := 'SAL' ;
  413.   mn[shr_] := 'SHR' ;   mn[sar ] := 'SAR' ;   mn[rol ] := 'ROL' ;
  414.   mn[ror ] := 'ROR' ;   mn[rcl ] := 'RCL' ;   mn[rcr ] := 'RCR' ;
  415.   mn[and_] := 'AND' ;   mn[or_ ] := 'OR'  ;   mn[test_] := 'TEST';
  416.   mn[xor_] := 'XOR' ;   mn[rep ] := 'REP' ;   mn[repne] := 'REPNE';
  417.   mn[repe] := 'REPE';   mn[repz] := 'REPZ';   mn[repnz] := 'REPNZ';
  418.   mn[movs] := 'MOVS';   mn[neg ] := 'NEG' ;   mn[nop ] := 'NOP' ;
  419.   mn[cmps] := 'CMPS';   mn[scas] := 'SCAS';   mn[lods] := 'LODS';
  420.   mn[stos] := 'STOS';   mn[call] := 'CALL';   mn[jmp ] := 'JMP' ;
  421.   mn[ret ] := 'RET' ;   mn[je  ] := 'JE'  ;   mn[jz  ] := 'JZ'  ;
  422.   mn[jl  ] := 'JL'  ;   mn[jnge] := 'JNGE';   mn[jle ] := 'JLE' ;
  423.   mn[jng ] := 'JNG' ;   mn[jb  ] := 'JB'  ;   mn[jnae] := 'JNAE';
  424.   mn[jbe ] := 'JBE' ;   mn[jna ] := 'JNA' ;   mn[jp  ] := 'JP'  ;
  425.   mn[jpe ] := 'JPE' ;   mn[jo  ] := 'JO'  ;   mn[js  ] := 'JS'  ;
  426.   mn[jne ] := 'JNE' ;   mn[jnz ] := 'JNZ' ;   mn[jnl ] := 'JNL' ;
  427.   mn[jge ] := 'JGE' ;   mn[jnle] := 'JNLE';   mn[jg  ] := 'JG'  ;
  428.   mn[jnb ] := 'JNB' ;   mn[jae ] := 'JAE' ;   mn[jnbe] := 'JNBE';
  429.   mn[ja  ] := 'JA'  ;   mn[jnp ] := 'JNP' ;   mn[jpo ] := 'JPO' ;
  430.   mn[jno ] := 'JNO' ;   mn[jns ] := 'JNS' ;   mn[loopz ] := 'LOOPZ' ;
  431.   mn[loop] := 'LOOP';   mn[jcxz] := 'JCXZ';   mn[loopnz] := 'LOOPNZ';
  432.   mn[int ] := 'INT' ;   mn[into] := 'INTO';   mn[loope ] := 'LOOPE' ;
  433.   mn[iret] := 'IRET';   mn[clc ] := 'CLC' ;   mn[loopne] := 'LOOPNE';
  434.   mn[cmc ] := 'CMC' ;   mn[stc ] := 'STC' ;   mn[cld ] := 'CLD' ;
  435.   mn[std ] := 'STD' ;   mn[cli ] := 'CLI' ;   mn[sti ] := 'STI' ;
  436.   mn[hlt ] := 'HLT' ;   mn[wait] := 'WAIT';   mn[esc ] := 'ESC' ;
  437.   mn[lock] := 'LOCK';
  438.   mn[valid] := '';
  439.   mn[db  ] := 'DB'  ;   mn[assume ] := 'ASSUME' ;
  440.   mn[dd  ] := 'DD'  ;   mn[comment] := 'COMMENT';
  441.   mn[dq  ] := 'DQ'  ;   mn[extrn  ] := 'EXTRN'  ;
  442.   mn[dt  ] := 'DT'  ;   mn[group  ] := 'GROUP'  ;
  443.   mn[dw  ] := 'DW'  ;   mn[include] := 'INCLUDE';
  444.   mn[end_] := 'END' ;   mn[label_ ] := 'LABEL'  ;
  445.   mn[equ ] := 'EQU' ;   mn[public ] := 'PUBLIC' ;
  446.   mn[even] := 'EVEN';   mn[record_] := 'RECORD' ;
  447.   mn[name] := 'NAME';   mn[segment] := 'SEGMENT';
  448.   mn[org ] := 'ORG' ;   mn[struc  ] := 'STRUC'  ;
  449.   mn[proc] := 'PROC';   mn[macro  ] := 'MACRO'  ;
  450.   mn[endm] := 'ENDM';   mn[subttl ] := 'SUBTTL' ;
  451.   mn[page] := 'PAGE';   mn[title  ] := 'TITLE'  ;
  452.   mn[fld   ] := 'FLD'   ;  mn[fst   ] := 'FST'   ;  mn[fstp  ] := 'FSTP'  ;
  453.   mn[fxch  ] := 'FXCH'  ;  mn[fcom  ] := 'FCOM'  ;  mn[fcomp ] := 'FCOMP' ;
  454.   mn[fcompp] := 'FCOMPP';  mn[ftst  ] := 'FTST'  ;  mn[fxam  ] := 'FXAM'  ;
  455.   mn[fadd  ] := 'FADD'  ;  mn[fsub  ] := 'FSUB'  ;  mn[fmul  ] := 'FMUL'  ;
  456.   mn[fdiv  ] := 'FDIV'  ;  mn[fsqrt ] := 'FSQRT' ;  mn[fscale] := 'FSCALE';
  457.   mn[fprem ] := 'FPREM' ;  mn[fabs  ] := 'FABS'  ;  mn[frndint] := 'FRNDINT';
  458.   mn[fchs  ] := 'FCHS'  ;  mn[fptan ] := 'FPTAN' ;  mn[fxtract] := 'FXTRACT';
  459.   mn[fpatan] := 'FPATAN';  mn[f2xm1 ] := 'F2XM1' ;  mn[fyl2x ] := 'FYL2X' ;
  460.   mn[fldz  ] := 'FLDZ'  ;  mn[fld1  ] := 'FLD1'  ;  mn[fyl2xp1] := 'FYL2XP1';
  461.   mn[fldpi ] := 'FLDPI' ;  mn[fldl2t] := 'FLDL2T';  mn[fldl2e] := 'FLDL2E';
  462.   mn[fldlg2] := 'FLDLG2';  mn[fldln2] := 'FLDLN2';  mn[finit ] := 'FINIT' ;
  463.   mn[feni  ] := 'FENI'  ;  mn[fdisi ] := 'FDISI' ;  mn[fldcw ] := 'FLDCW' ;
  464.   mn[fstcw ] := 'FSTCW' ;  mn[fstsw ] := 'FSTSW' ;  mn[fclex ] := 'FCLEX' ;
  465.   mn[fstenv] := 'FSTENV';  mn[fldenv] := 'FLDENV';  mn[fsave ] := 'FSAVE' ;
  466.   mn[frstor] := 'FRSTOR';  mn[ffree ] := 'FFREE' ;  mn[fincstp] := 'FINCSTP';
  467.   mn[fnop  ] := 'FNOP'  ;  mn[fwait ] := 'FWAIT' ;  mn[fdecstp] := 'FDECSTP';
  468.  
  469.   reg[ax] := 'AX';  reg[bx] := 'BX';  reg[cx] := 'CX';  reg[dx] := 'DX';
  470.   reg[sp] := 'SP';  reg[bp] := 'BP';  reg[si] := 'SI';  reg[di] := 'DI';
  471.   reg[al] := 'AL';  reg[bl] := 'BL';  reg[cl] := 'CL';  reg[dl] := 'DL';
  472.   reg[ah] := 'AH';  reg[bh] := 'BH';  reg[ch] := 'CH';  reg[dh] := 'DH';
  473.   reg[ds] := 'DS';  reg[ss] := 'SS';  reg[cs] := 'CS';  reg[es] := 'ES';
  474.   rn[ax] := 0;      rn[bx] := 3;      rn[cx] := 1;      rn[dx] := 2;
  475.   rn[sp] := 4;      rn[bp] := 5;      rn[si] := 6;      rn[di] := 7;
  476.   rn[al] := 0;      rn[bl] := 3;      rn[cl] := 1;      rn[dl] := 2;
  477.   rn[ah] := 4;      rn[bh] := 7;      rn[ch] := 5;      rn[dh] := 6;
  478.   rn[ds] := 3;      rn[ss] := 2;      rn[cs] := 1;      rn[es] := 0;
  479. end;   { init }
  480.  
  481. function search(symbol: idtype): boolean;     { search symbol table }
  482. begin                                         { return index in global n }
  483.   n := 0;
  484.   symbol := stupcase(symbol);
  485.   while (tab[n].id <> symbol) and (n <= tcnt) do n := n+1;
  486.   if n = tcnt+1
  487.   then search := false
  488.   else search := true;
  489. end;
  490.  
  491. procedure generate;                   { pass 2 -- maintain location counter }
  492.                                       { pass 3 -- generate object code }
  493. var
  494.   q0,w,md,rm: byte;
  495.   q1: integer;
  496.  
  497.   procedure oneop;         { test for exactly one operand }
  498.   begin
  499.       if op2.isop then error(11);
  500.       if not op1.isop then error(1);
  501.   end;
  502.  
  503.   procedure emit(q:byte);             { emit one byte }
  504.     function hex(d:byte): char;
  505.     begin
  506.       if d <= 9
  507.       then hex := chr(48+d)
  508.       else hex := chr(55+d);
  509.     end;
  510.   begin
  511.     loc := loc+1;
  512.     if (pass=3) and (errn = 0) then begin
  513.       if atstart then t := t+' ' else t := t+'/';
  514.       atstart := false;
  515.       t := t+'$'+hex(q shr 4)+hex(q and 15);
  516.     end;
  517.   end;
  518.  
  519.   procedure emit2(q:integer);         { emit two bytes }
  520.   begin
  521.     begin
  522.       emit(q and $ff);
  523.       emit(q shr 8);
  524.     end
  525.   end;
  526.  
  527.   procedure emitid(ident: idtype);    { emit identifier }
  528.   begin
  529.     loc := loc+2;
  530.     if (pass=3) and (errn = 0) then t := t+'/'+ident;
  531.   end;
  532.  
  533.   procedure emitimm(op:attr);         { emit immediate value }
  534.   begin
  535.   with op do
  536.     if isid then emitid(ident)
  537.     else if isconst then if (w=1) then emit2(value) else emit(value)
  538.     else error(10);
  539.   end;
  540.  
  541.   procedure checktype(op1,op2:attr);  { check compatibility of operands }
  542.   begin
  543.     if (op1.isword and not op2.isbyte) or (op2.isword and not op1.isbyte)
  544.     then w := 1
  545.     else if (op1.isbyte and not op2.isword) or (op2.isbyte and not op1.isword)
  546.          then w := 0
  547.     else if not (op1.isbyte or op1.isword or op2.isbyte or op2.isword)
  548.          then error(7)
  549.     else error(3);
  550.     if op1.issreg or op2.issreg then w := 0;
  551.   end;
  552.  
  553.   procedure modrm(q:byte; op:attr);       { construct the modregr/m byte }
  554.   begin
  555.   with op do begin
  556.     if isid then md := 2
  557.     else if isconst
  558.       then if (value <= 127) and (value >= -128) then md := 1 else md := 2
  559.     else md := 0;
  560.  
  561.     if isidx and isbase
  562.     then begin
  563.       if base = bx then rm := 0 else rm := 2;
  564.       if idx = di then rm := rm+1;
  565.       end
  566.     else if not isidx and not isbase
  567.     then begin
  568.       md := 0; rm := 6; end
  569.     else begin
  570.       rm := 4;
  571.       if isidx and (idx = di) then rm := rm+1;
  572.       if isbase
  573.       then if base = bp then rm := rm+2 else rm := rm+3;
  574.       end;
  575.       emit((md shl 6)+(q shl 3)+rm);
  576.       if isid then emitid(ident);
  577.       if isconst then begin
  578.         if (value <= 127) and (value >= -128) then begin
  579.           emit(value);
  580.           if (md=0) and (rm=6) then if value<0 then emit($ff) else emit(0);
  581.           end
  582.         else emit2(value);
  583.         end;
  584.   end; end;
  585.  
  586.   procedure regtoreg(q:byte; op1,op2:attr);
  587.   begin
  588.     checktype(op1,op2);
  589.     emit(q+w);
  590.     emit(192 + (rn[op1.rg] shl 3) + rn[op2.rg]);
  591.   end;
  592.  
  593.   procedure imtoacc(q:byte; op1,op2:attr);
  594.   begin
  595.     checktype(op1,op2);
  596.     emit(q+w);
  597.     emitimm(op2);
  598.   end;
  599.  
  600.   procedure imtoreg(q:byte; op1,op2:attr);
  601.   begin
  602.     if op1.isword and op2.isbyte then w := 1 else checktype(op1,op2);
  603.     emit(q+(w shl 3)+rn[op1.rg]);
  604.     emitimm(op2);
  605.   end;
  606.  
  607.   procedure onerm(q:byte; op:attr);
  608.   begin
  609.   with op do begin
  610.     if isreg
  611.     then emit(192+(q shl 3)+rn[rg])
  612.     else if isaddr then modrm(q,op)
  613.     else error(10);
  614.   end;
  615.   end;
  616.  
  617.   procedure imtorm(q,r:byte; op1,op2:attr; ext:boolean);
  618.   begin
  619.     if op1.isbyte and op2.isword then error(3)
  620.     else if op1.isbyte and op2.isbyte then w := 0
  621.     else if op1.isword and op2.isword then w := 1
  622.     else if op1.isword and op2.isbyte then if ext then w := 3 else w := 1
  623.     else if op1.isaddr and op2.isbyte then w := 0
  624.     else if op1.isaddr and op2.isword then w := 1
  625.     else error(29);
  626.     emit(q+w);
  627.     onerm(r,op1);
  628.     emitimm(op2);
  629.   end;
  630.  
  631.   procedure regmem(q: byte; op1,op2: attr);
  632.   begin
  633.     checktype(op1,op2);
  634.     emit(q+w);
  635.     modrm(rn[op1.rg],op2);
  636.   end;
  637.  
  638.   procedure inout(q:byte; op1,op2:attr);
  639.   begin
  640.     if not (op1.isreg and (op1.rg in [ax,al])) then error(10);
  641.     if op1.rg=ax then w := 1 else w := 0;
  642.     if op2.isconst then begin
  643.       if op2.isidx or op2.isbase then error(10);
  644.       if (op2.value < 0) or (op2.value > 255) then error(12);
  645.       emit(q+w);
  646.       emit(op2.value);
  647.       end
  648.     else if op2.isreg and (op2.rg=dx) then emit(q+8+w)
  649.     else error(10);
  650.   end;
  651.  
  652. begin   { generate }
  653.   t := ''; errn := codpnt^.errn;
  654.   op1 := codpnt^.op1; op2 := codpnt^.op2;
  655.   with codpnt^ do begin
  656.   if errn=0 then begin
  657.     if repx in [rep,repne,repnz] then emit($f2);
  658.     if repx in [repe,repz] then emit($f3);
  659.     if lockx then emit($f0);
  660.     if override in [ds,cs,ss,es] then emit($26+(rn[override] shl 3));
  661.  
  662.     case op of
  663.  
  664.    nul: ;
  665.  
  666.    mov: begin
  667.       w := 1;
  668.       if not (op1.isop and op2.isop)
  669.       then error(1)
  670.       else if op1.issreg then begin
  671.           if op1.rg=cs then error(10);
  672.           q0 := $8e;
  673.           if op2.isreg then regtoreg(q0,op1,op2)
  674.           else if op2.isaddr then regmem(q0,op1,op2)
  675.           else error(10);
  676.         end
  677.       else if op2.issreg then begin
  678.           q0 := $8c;
  679.           if op1.isreg then regtoreg(q0,op2,op1)
  680.           else if op1.isaddr then regmem(q0,op2,op1)
  681.           else error(10);
  682.         end
  683.       else if op2.isimmed then begin
  684.           if op1.isreg
  685.           then imtoreg($b0,op1,op2)
  686.           else imtorm($c6,0,op1,op2,false);
  687.         end
  688.       else if op1.isreg and (op1.rg in [ax,al]) and op2.isaddr
  689.               and not op2.isbase and not op2.isidx then begin
  690.           if op1.rg = ax then emit($a1) else emit($a0);
  691.           emitimm(op2);
  692.         end
  693.       else if op2.isreg and (op2.rg in [ax,al]) and op1.isaddr
  694.               and not op1.isbase and not op1.isidx then begin
  695.           if op2.rg = ax then emit($a3) else emit($a2);
  696.           emitimm(op1);
  697.         end
  698.       else if op1.isreg and op2.isreg then begin
  699.           q0 := $8a;
  700.           regtoreg(q0,op1,op2); end
  701.       else if (op1.isreg and op2.isaddr) or (op1.isaddr and op2.isreg)
  702.         then begin
  703.           q0 := $88;
  704.           if op1.isaddr
  705.           then regmem(q0,op2,op1)
  706.           else begin
  707.             q0 := q0+2;
  708.             regmem(q0,op1,op2)
  709.             end
  710.         end
  711.       else error(10);
  712.     end;
  713.  
  714.    add,adc,sub,sbb,cmp,and_,or_,xor_,test_:
  715.     begin
  716.       if not (op1.isop and op2.isop)
  717.       then error(1)
  718.       else
  719.       if op2.isimmed
  720.       then if op1.isreg and ((op1.rg=ax) or (op1.rg=al))
  721.            then begin
  722.              if op1.isword then op2.isbyte := false;
  723.              case op of
  724.             add: q0 := $04;
  725.             adc: q0 := $14;
  726.             sub: q0 := $2c;
  727.             sbb: q0 := $1c;
  728.             cmp: q0 := $3c;
  729.             and_: q0 := $24;
  730.             or_ : q0 := $0c;
  731.             xor_: q0 := $34;
  732.             test_: q0 := $a8;
  733.              end;
  734.              imtoacc(q0,op1,op2);
  735.            end
  736.            else begin
  737.              q0 := $80;
  738.              case op of
  739.             add: q1 := 0;
  740.             adc: q1 := 2;
  741.             sub: q1 := 5;
  742.             sbb: q1 := 3;
  743.             cmp: q1 := 7;
  744.             and_: q1 := 4;
  745.             or_ : q1 := 1;
  746.             xor_: q1 := 6;
  747.             test_: begin q0 := $f6; q1 := 0; end;
  748.              end;
  749.              if op in [add,adc,sub,sbb,cmp]
  750.              then imtorm(q0,q1,op1,op2,true)
  751.              else imtorm(q0,q1,op1,op2,false);
  752.            end
  753.  
  754.       else if op1.isreg and op2.isreg
  755.            then begin
  756.              case op of
  757.             add: q0 := $02;
  758.             adc: q0 := $12;
  759.             sub: q0 := $2a;
  760.             sbb: q0 := $1a;
  761.             cmp: q0 := $3a;
  762.             and_: q0 := $22;
  763.             or_ : q0 := $0a;
  764.             xor_: q0 := $32;
  765.             test_: q0 := $84;
  766.              end;
  767.              regtoreg(q0,op1,op2);
  768.            end
  769.       else if (op1.isaddr and op2.isreg) or (op1.isreg and op2.isaddr)
  770.            then begin
  771.              case op of
  772.             add: q0 := $00;
  773.             adc: q0 := $10;
  774.             sub: q0 := $28;
  775.             sbb: q0 := $18;
  776.             cmp: q0 := $38;
  777.             and_: q0 := $20;
  778.             or_ : q0 := $08;
  779.             xor_: q0 := $30;
  780.             test_: q0 := $84;
  781.              end;
  782.              if op1.isaddr
  783.              then regmem(q0,op2,op1)
  784.              else begin
  785.                if op<>test_ then q0 := q0+2;
  786.                regmem(q0,op1,op2)
  787.                end
  788.            end
  789.       else error(10);
  790.     end;
  791.  
  792.    push,pop:
  793.     begin
  794.     with op1 do begin
  795.       oneop;
  796.       if issreg then begin
  797.         if (op=pop) and (rg=cs) then error(10);
  798.         case op of
  799.        push: q0 := $06;
  800.        pop:  q0 := $07;
  801.         end;
  802.         emit(q0+(rn[rg] shl 3));
  803.         end
  804.       else if isreg then begin
  805.         if not isword then error(3);
  806.         case op of
  807.        push: q0 := $50;
  808.        pop:  q0 := $58;
  809.         end;
  810.         emit(q0+rn[rg]);
  811.         end
  812.       else if isaddr then begin
  813.         if isbyte then error(3);
  814.         case op of
  815.        push: begin q0 := $ff; q1 := 6; end;
  816.        pop:  begin q0 := $8f; q1 := 0; end;
  817.         end;
  818.         emit(q0);
  819.         onerm(q1,op1);
  820.         end
  821.       else error(10);
  822.     end;
  823.     end;
  824.  
  825.    inc,dec:
  826.     begin
  827.     with op1 do begin
  828.       oneop;
  829.       if isreg and isword then begin
  830.         case op of
  831.        inc: q0 := $40;
  832.        dec: q0 := $48;
  833.         end;
  834.         emit(q0+rn[rg]);
  835.         end
  836.       else if isaddr or isreg then begin
  837.         if isbyte then w := 0
  838.         else if isword then w := 1
  839.         else error(7);
  840.         case op of
  841.        inc: q1 := 0;
  842.        dec: q1 := 1;
  843.         end;
  844.         emit($fe+w);
  845.         onerm(q1,op1);
  846.         end
  847.       else error(10);
  848.     end;
  849.     end;
  850.  
  851.    xchg:
  852.     begin
  853.       if not op2.isop then error(1);
  854.       if op1.isreg and op2.isreg and ((op1.rg=ax) or (op2.rg=ax))
  855.       then begin
  856.         if op1.rg<>ax
  857.         then emit($90+rn[op1.rg])
  858.         else emit($90+rn[op2.rg]);
  859.         end
  860.       else if op1.isreg and op2.isreg
  861.       then regtoreg($86,op1,op2)
  862.       else if op1.isreg and op2.isaddr
  863.       then regmem($86,op1,op2)
  864.       else if op1.isaddr and op2.isreg
  865.       then regmem($86,op2,op1)
  866.       else error(10);
  867.     end;
  868.  
  869.    mul,imul,div_,idiv,neg,not_:
  870.     begin
  871.       oneop;
  872.       if op1.isbyte then q0 := $f6
  873.       else if op1.isword then q0 := $f7
  874.       else error(7);
  875.       case op of
  876.      mul:  q1 := 4;
  877.      imul: q1 := 5;
  878.      div_:  q1 := 6;
  879.      idiv: q1 := 7;
  880.      neg:  q1 := 3;
  881.      not_:  q1 := 2;
  882.       end;
  883.       emit(q0);
  884.       onerm(q1,op1);
  885.     end;
  886.  
  887.    in_: inout($e4,op1,op2);
  888.    out: inout($e6,op2,op1);
  889.  
  890.    lea,lds,les:
  891.     begin
  892.       if not op2.isop then error(1);
  893.       if not(op1.isreg and op1.isword and op2.isaddr) then error(10);
  894.       case op of
  895.      lea: q0 := $8d;
  896.      lds: q0 := $c5;
  897.      les: q0 := $c4;
  898.       end;
  899.       emit(q0);
  900.       onerm(rn[op1.rg],op2);
  901.     end;
  902.  
  903.    shl_,sal,shr_,sar,rol,ror,rcl,rcr:
  904.     begin
  905.     with op2 do begin
  906.       if not isop then error(1);
  907.       if isidx or isbase then error(10);
  908.       if isconst and (value=1) then q0 := $d0
  909.       else if isreg and (rg=cl) then q0 := $d2
  910.       else error(10);
  911.       case op of
  912.      shl_,sal: q1 := 4;
  913.      shr_: q1 := 5;
  914.      sar: q1 := 7;
  915.      rol: q1 := 0;
  916.      ror: q1 := 1;
  917.      rcl: q1 := 2;
  918.      rcr: q1 := 3;
  919.       end;
  920.       if op1.isword
  921.       then q0 := q0+1
  922.       else if not op1.isbyte then error(7);
  923.       if not(op1.isreg or op1.isaddr) then error(10);
  924.       emit(q0);
  925.       onerm(q1,op1);
  926.     end;
  927.     end;
  928.  
  929.    lods,stos,scas:
  930.     begin
  931.     with op1 do begin
  932.       if op2.isop then error(11);
  933.       if not op1.isop then error(7);
  934.       case op of
  935.      lods: q0 := $ac;
  936.      stos: q0 := $aa;
  937.      scas: q0 := $ae;
  938.       end;
  939.       if isword then q0 := q0+1 else if not isbyte then error(7);
  940.       if isbase or isimmed or isreg then error(10);
  941.       if isidx and (((idx=si) and (op in [stos,scas]))
  942.                     or ((idx=di) and (op=lods))) then error(10);
  943.       emit(q0);
  944.     end; end;
  945.  
  946.    movs,cmps:
  947.     begin
  948.       if op2.isop then begin
  949.         checktype(op1,op2);
  950.         if op2.isidx and (((op2.idx=di) and (op=movs))
  951.            or ((op2.idx=si) and (op=cmps))) then error(10);
  952.         if op2.isbase or op2.isimmed or op2.isreg then error(10);
  953.         end
  954.       else if op1.isop then begin
  955.         if op1.isword then w := 1
  956.         else if op1.isbyte then w := 0
  957.         else error(7);
  958.         if op1.isimmed or op1.isreg or op1.isaddr then error(10);
  959.         end
  960.       else error(7);
  961.       if op1.isop then begin
  962.         if op1.isbase or op1.isimmed or op1.isreg then error(10);
  963.         if op1.isidx and (((op1.idx=si) and (op=movs))
  964.            or ((op1.idx=di) and (op=cmps))) then error(10);
  965.         end;
  966.       case op of
  967.      movs: emit($a4+w);
  968.      cmps: emit($a6+w);
  969.       end;
  970.     end;
  971.  
  972.    ret:
  973.     begin
  974.       if op2.isop then error(11);
  975.       if not op1.isop then error(1);
  976.       with op1 do begin
  977.         if isidx or isbase or isreg or isid then error(10);
  978.         if isconst then q0 := $c2 else q0 := $c3;
  979.         if isfar then q0 := q0+8
  980.         else if not isnear
  981.           then if isshort then error(10) else error(7);
  982.         emit(q0);
  983.         if isconst then emit2(value);
  984.       end
  985.     end;
  986.  
  987.    jmp,call:
  988.     begin
  989.     with op1 do begin
  990.       w := 1;
  991.       if op2.isop then begin
  992.         if not (isimmed and op2.isimmed) then error(10);
  993.         if isnear or op2.isnear then error(3);
  994.         case op of
  995.        jmp:  emit($ea);
  996.        call: emit($9a);
  997.         end;
  998.         emitimm(op1);
  999.         emitimm(op2);
  1000.         end
  1001.       else if not op1.isop then error(1)
  1002.       else if isfar then begin
  1003.         if (not isaddr) or (isid and search(ident)) then error(10);
  1004.         emit($ff);
  1005.         case op of
  1006.        jmp:  onerm(5,op1);
  1007.        call: onerm(3,op1);
  1008.         end;
  1009.         end
  1010.       else if isimmed and isconst then begin
  1011.         if (value<=127) and (value>=-128) and (op=jmp)
  1012.         then begin emit($eb); emit(value); end
  1013.         else begin
  1014.           case op of
  1015.          jmp:  emit($e9);
  1016.          call: emit($e8);
  1017.           end;
  1018.           emitimm(op1); end;
  1019.         end
  1020.       else if isid and search(ident) then begin
  1021.         if isidx or isbase then error(2);
  1022.         q1 := tab[n].val-loc-2;
  1023.         if pass=3 then begin
  1024.           if (op=jmp) and (q1 >= -128) and (q1 <= 127)
  1025.           then begin
  1026.             emit($eb);
  1027.             if isshort then emit(q1)
  1028.             else begin emit(q1); emit($90); end;
  1029.             end
  1030.           else begin
  1031.             case op of
  1032.            jmp:  begin
  1033.               if isshort then error(17);
  1034.               emit($e9); end;
  1035.            call: begin
  1036.               if isshort then error(10);
  1037.               emit($e8); end;
  1038.             end;
  1039.             emit2(q1-1);
  1040.             end;
  1041.           end
  1042.         else begin  {pass2}
  1043.             if (op=jmp) and (isshort or ((tab[n].val > -1) and (q1 > -128)))
  1044.             then begin emit2(0); isshort := true; end
  1045.             else begin emit2(0); emit(0); end;
  1046.           end;
  1047.         end
  1048.       else if (isreg or isaddr) and not (isbyte or isshort) then begin
  1049.         if not (isnear or isreg) then error(7);
  1050.         emit($ff);
  1051.         case op of
  1052.        jmp:  onerm(4,op1);
  1053.        call: onerm(2,op1);
  1054.         end;
  1055.         end
  1056.       else error(10);
  1057.     end;
  1058.     end;
  1059.  
  1060.    je,jz,jl,jnge,jle,jng,jb,jnae,jbe,jna,jp,jpe,jo,js,jne,jnz,jnl,jge,jnle,
  1061.    jg,jnb,jae,jnbe,ja,jnp,jpo,jno,jns,loop,loopz,loope,loopnz,loopne,jcxz:
  1062.     begin
  1063.       oneop;
  1064.       with op1 do begin
  1065.       if (isimmed and isconst)
  1066.       then if not ((value>=-128) and (value<=127)) then error(12) else
  1067.       else if not (isid and not (isidx or isbase)) then error(10);
  1068.       case op of
  1069.      je,jz:   q0 := $74;
  1070.      jl,jnge: q0 := $7c;
  1071.      jle,jng: q0 := $7e;
  1072.      jb,jnae: q0 := $72;
  1073.      jbe,jna: q0 := $76;
  1074.      jp,jpe:  q0 := $7a;
  1075.      jo:      q0 := $70;
  1076.      js:      q0 := $78;
  1077.      jne,jnz: q0 := $75;
  1078.      jnl,jge: q0 := $7d;
  1079.      jnle,jg: q0 := $7f;
  1080.      jnb,jae: q0 := $73;
  1081.      jnbe,ja: q0 := $77;
  1082.      jnp,jpo: q0 := $7b;
  1083.      jno:     q0 := $71;
  1084.      jns:     q0 := $79;
  1085.      loop:          q0 := $e2;
  1086.      loopz,loope:   q0 := $e1;
  1087.      loopnz,loopne: q0 := $e0;
  1088.      jcxz:          q0 := $e3;
  1089.       end;
  1090.       if isconst
  1091.       then begin emit(q0); emit(value); end
  1092.       else begin
  1093.         if (pass=3) and not search(ident) then error(16);
  1094.         q1 := tab[n].val-loc-2;
  1095.         if (pass=3) and ((q1 < -128) or (q1 > 127)) then error(17);
  1096.         emit(q0);
  1097.         emit(q1);
  1098.         end;
  1099.       end;
  1100.     end;
  1101.  
  1102.    int:
  1103.     begin
  1104.     with op1 do begin
  1105.       oneop;
  1106.       if isidx or isbase or not isconst then error(10);
  1107.       if (value < 0) or (value > 255) then error(12);
  1108.       if value=3 then emit($cc)
  1109.       else begin emit($cd); emit(value); end;
  1110.     end;
  1111.     end;
  1112.  
  1113.    esc:
  1114.     begin
  1115.       if not op2.isop then error(1);
  1116.       if not op1.isimmed then error(10);
  1117.       if (op1.value < 0) or (op1.value > 63) then error(10);
  1118.       emit($d8+(op1.value shr 3));
  1119.       onerm((op1.value and 7),op2);
  1120.     end;
  1121.  
  1122.    xlat,lahf,sahf,pushf,popf,aaa,daa,aas,das,cbw,cwd,into,iret,clc,cmc,
  1123.    stc,cld,std,cli,sti,hlt,wait,aam,aad,nop:
  1124.     begin
  1125.       if op1.isop then error(11);
  1126.       case op of
  1127.      xlat: emit($d7);
  1128.      lahf: emit($9f);
  1129.      sahf: emit($9e);
  1130.      pushf:emit($9c);
  1131.      popf: emit($9d);
  1132.      aaa:  emit($37);
  1133.      daa:  emit($27);
  1134.      aas:  emit($3f);
  1135.      das:  emit($2f);
  1136.      cbw:  emit($98);
  1137.      cwd:  emit($99);
  1138.      into: emit($ce);
  1139.      iret: emit($cf);
  1140.      clc:  emit($f8);
  1141.      cmc:  emit($f5);
  1142.      stc:  emit($f9);
  1143.      cld:  emit($fc);
  1144.      std:  emit($fd);
  1145.      cli:  emit($fa);
  1146.      sti:  emit($fb);
  1147.      hlt:  emit($f4);
  1148.      wait: emit($9b);
  1149.      aam:  begin emit($d4); emit($0a); end;
  1150.      aad:  begin emit($d5); emit($0a); end;
  1151.      nop:  emit($90);
  1152.       end;
  1153.     end;
  1154.  
  1155.     else error(29);
  1156.     end; { case op }
  1157.   end; { if errn }
  1158.  
  1159.   if pass=3 then begin                { finish constructing the target line }
  1160.     if codpnt = firstentry
  1161.     then begin
  1162.       writeln(targ,'Inline(');
  1163.       writeln; writeln('Inline('); end;
  1164.     message;
  1165.     if next = nil then  t := t + '  );';
  1166.     while length(t) < 25 do t := t+' ';
  1167.     t := t + '   { ' + source;
  1168.     if length(t) < oldlen-4          { make it look pretty }
  1169.     then begin
  1170.       if length(t) > oldlen-8 then oldlen := oldlen+2;
  1171.       while length(t) < oldlen-4 do t := t+' ';
  1172.       end;
  1173.     t := t+' }';
  1174.     oldlen := length(t);
  1175.     writeln(targ,t); writeln(t);     { and write it to the file }
  1176.     codpnt := next;
  1177.   end;
  1178.  
  1179. end; {with}
  1180. end; { generate }
  1181.  
  1182.  
  1183. procedure address;         { compute address of each label }
  1184.  
  1185. begin
  1186.   if codpnt^.labeln <> 0
  1187.   then tab[codpnt^.labeln].val := loc;
  1188.   generate;                { advance location counter }
  1189.   codpnt^.errn := errn;
  1190.   codpnt := codpnt^.next;
  1191. end;
  1192.  
  1193.  
  1194. procedure parse_line;       { scan source and build intermediate code }
  1195.  
  1196. var
  1197.   s: line;       { source line }
  1198.   p: integer;    { index into s }
  1199.   m: idtype;     { mnemonic opcode }
  1200.   labeln: integer;
  1201.   temp: line;
  1202.   id: idtype;    { identifier }
  1203.   preventry: cptr;    { points to previous line of intermediate code }
  1204.  
  1205. label nocode;
  1206.  
  1207.   function more: boolean;      { any more characters on this line? }
  1208.   begin
  1209.     more := p <= length(s);
  1210.   end;
  1211.  
  1212.   procedure skipblank;
  1213.   begin
  1214.     while more and (s[p] = ' ') do
  1215.     p := p+1;
  1216.   end;
  1217.  
  1218.   function alpha: boolean;
  1219.   begin
  1220.     alpha := more and (s[p] in ['a'..'z','A'..'Z']);
  1221.   end;
  1222.  
  1223.   function digit: boolean;
  1224.   begin
  1225.     digit := more and (s[p] in ['0'..'9']);
  1226.   end;
  1227.  
  1228.   function peek(aset: charset): boolean;   { is next character in aset? }
  1229.   begin
  1230.     if more and (s[p] in aset) then peek := true else peek := false;
  1231.   end;
  1232.  
  1233.   function test(c: char): boolean;       { is the next character c? }
  1234.   begin                                  { if so, scan over it      }
  1235.     if more and (upcase(s[p]) = c)
  1236.     then begin
  1237.       p := p+1; skipblank;
  1238.       test := true
  1239.       end
  1240.     else test := false
  1241.   end;
  1242.  
  1243.   procedure getid;               { found an alpha }
  1244.   begin                          { get rest of identifier }
  1245.     id := '';
  1246.     while alpha or digit or peek(['_']) do begin
  1247.       if length(id) < 20
  1248.       then id := id + s[p]       { return it in id }
  1249.       else error(14);
  1250.       p := p+1;
  1251.     end;
  1252.     skipblank;
  1253.   end;
  1254.  
  1255.   procedure enter(symbol: idtype; var m: integer);
  1256.                                { make entry in symbol table }
  1257.   begin
  1258.     if search(symbol)
  1259.     then error(15)
  1260.     else if tcnt = tsize then begin
  1261.       writeln; writeln('Assembly Aborted -- Symbol Table Full');
  1262.       close(src); close(targ);
  1263.       halt; end
  1264.     else begin
  1265.       tcnt := tcnt+1;
  1266.       tab[tcnt].id := stupcase(symbol);
  1267.       tab[tcnt].val := -1;
  1268.       m := tcnt;
  1269.     end;
  1270.   end;
  1271.  
  1272.   function code: boolean;            { found an id }
  1273.                                      { is it an opcode? }
  1274.   begin
  1275.     op := nul;
  1276.     m := stupcase(id);
  1277.     repeat                           { if so, return it in op }
  1278.       op := succ(op)
  1279.     until (mn[op] = m) or (op = last);
  1280.     if op in [rep,repe,repz,repne,repnz] then begin
  1281.       if repx <> nul then error(13);
  1282.       repx := op;                      { REP prefix }
  1283.       if alpha then begin              { look for another opcode }
  1284.         getid;
  1285.         code := code; end
  1286.       else error(4);
  1287.       end
  1288.     else if op=lock then begin
  1289.       if lockx then error(13);
  1290.       lockx := true;                   { LOCK prefix }
  1291.       if alpha then begin              { look for another opcode }
  1292.         getid;
  1293.         code := code; end
  1294.       else error(4);
  1295.       end
  1296.     else if (op > valid) and (op <> last) then error(18)
  1297.     else if op <> last then begin
  1298.       code := true;
  1299.       if (repx<>nul) and not (op in [movs,cmps,scas,lods,stos]) then error(4);
  1300.       end
  1301.     else begin code := false; op := nul; end;
  1302.   end;  { code }
  1303.  
  1304.   procedure getoperand(var opr: attr);    { scan an operand }
  1305.                                           { determine its attributes }
  1306.   var r: regs;
  1307.  
  1308.   label gotid;
  1309.  
  1310.     procedure makebyte;         { it's a byte }
  1311.     begin
  1312.       if opr.isword then error(3) else opr.isbyte := true;
  1313.     end;
  1314.  
  1315.     procedure makeword;         { it's a word }
  1316.     begin
  1317.       if opr.isbyte then error(3) else opr.isword := true;
  1318.     end;
  1319.  
  1320.     procedure getnum;           { scan a numeric literal }
  1321.  
  1322.     var code: integer;
  1323.         minus: boolean;
  1324.  
  1325.       procedure gethex;           { scan a hexadecimal literal }
  1326.       begin
  1327.         if id = '-' then minus := true;
  1328.         id := '$'; p := p+1;
  1329.         while more and (digit or (upcase(s[p]) in ['A','B','C','D','E','F']))
  1330.         do begin
  1331.           id := id + s[p];        { return it in id }
  1332.           p := p+1;
  1333.         end;
  1334.         if id = '$' then error(2);
  1335.       end;
  1336.  
  1337.     begin
  1338.       id := ''; minus := false;
  1339.       if test('+') then;
  1340.       if test('-') then id := '-';
  1341.       if peek(['$'])
  1342.       then gethex                          { hex }
  1343.       else while digit do begin            { decimal }
  1344.         id := id + s[p];
  1345.         p := p+1;
  1346.       end;
  1347.       if id = '' then error(2);
  1348.       with opr do begin
  1349.         val(id,value,code);              { return value }
  1350.         if code<>0
  1351.         then if id='-32768'
  1352.           then value := $8000
  1353.           else error(9);
  1354.         if minus then value := -value
  1355.       end;
  1356.       if id[1] = '-' then delete(id,1,1);
  1357.       skipblank;
  1358.     end;   { getnum }
  1359.  
  1360.  
  1361.     procedure getchar;          { scan a character literal }
  1362.     begin
  1363.       with opr do begin
  1364.       p := p+1;
  1365.       value := ord(s[p]); p := p+1;
  1366.       if not test('''') then error(2)
  1367.       else begin
  1368.         isconst := true;
  1369.         isimmed := true;
  1370.         if not isword then isbyte := true;
  1371.       end;
  1372.     end; end;
  1373.  
  1374.     function testreg: boolean;        { is id a register name? }
  1375.     begin
  1376.       r := firstreg;
  1377.       temp := stupcase(id);
  1378.       repeat
  1379.         r := succ(r)                  { if so, return register number in r }
  1380.       until (reg[r] = temp) or (r = lastreg);
  1381.       if r <> lastreg then testreg := true else testreg := false;
  1382.     end;
  1383.  
  1384.  
  1385.   begin  {getoperand}
  1386.     with opr do begin
  1387.     isop := true;
  1388.     if not (alpha or digit or peek(['=','$','*','[','+','-','(','''']))
  1389.     then error(2)
  1390.     else begin
  1391.       if alpha then begin
  1392.         getid;
  1393.         if testreg and (r in [ds,cs,ss,es]) and peek([':'])
  1394.         then begin                                { segment override prefix }
  1395.           if test(':') then;
  1396.           if override<>lastreg then error(13);
  1397.           override := r; end
  1398.         else goto gotid;
  1399.         end;
  1400.       if test('(') then begin                     { type modifier }
  1401.         if test('B') then makebyte
  1402.         else if test('W') then makeword
  1403.         else if test('S') then isshort := true
  1404.         else if test('N') then isnear := true
  1405.         else if test('F') then isfar := true
  1406.         else error(6);
  1407.         if not test(')') then error(6);
  1408.         end;
  1409.       if test('=') then isimmed := true;
  1410.       if test('[')
  1411.       then begin                                  { base or index register }
  1412.         if isimmed then error(2);
  1413.         isaddr := true;
  1414.         getid;
  1415.         if testreg
  1416.         then begin
  1417.           if not test(']') then error(6);
  1418.           if r in [bx,bp]
  1419.           then begin                              { base register }
  1420.             isbase := true; isop := true;
  1421.             base := r;
  1422.             if test('[')
  1423.             then begin
  1424.               getid;
  1425.               if testreg
  1426.               then begin
  1427.                 if not test(']') then error(6);
  1428.                 if r in [si,di]
  1429.                 then begin                        { and index register }
  1430.                   isidx := true;
  1431.                   idx := r;
  1432.                   end
  1433.                 else error(8)
  1434.                 end
  1435.               else error(5)
  1436.               end
  1437.             end
  1438.           else if r in [si,di]
  1439.             then begin                            { index register }
  1440.               isidx := true;
  1441.               idx := r;
  1442.             end
  1443.           else error(8);
  1444.           end
  1445.         else error(5)
  1446.         end;
  1447.       if alpha
  1448.       then begin                                  { identifier }
  1449.         getid;
  1450. gotid:  if testreg
  1451.         then begin                                { it's a register }
  1452.           if r in [ds,ss,cs,es]
  1453.           then issreg := true
  1454.           else isreg := true;
  1455.           if r in [ax,bx,cx,dx,sp,bp,si,di,ds,ss,cs,es]
  1456.           then makeword;
  1457.           if r in [ah,bh,ch,dh,al,bl,cl,dl]
  1458.           then makebyte;
  1459.           if isimmed then error(2);
  1460.           rg := r;
  1461.           end
  1462.         else begin                              { it's a variable or label id }
  1463.           isaddr := not isimmed;
  1464.           isid := true;
  1465.           ident := id;
  1466.           if isimmed then makeword;
  1467.           end;
  1468.       end  {alpha}
  1469.       else if digit or peek(['$','+','-'])
  1470.       then begin                                  { numeric literal }
  1471.         getnum;
  1472.         isaddr := not isimmed;
  1473.         isconst := true;
  1474.         if isimmed
  1475.         then if (value <= 255) and (value >= -128) and not isword
  1476.              then makebyte
  1477.              else makeword;
  1478.       end
  1479.       else if test('*')
  1480.       then begin                                { location counter reference }
  1481.         ident := '*';
  1482.         isaddr := not isimmed;
  1483.         isid := true;
  1484.         if isimmed then makeword;
  1485.         if test('+') then ident := '*+';
  1486.         if test('-') then ident := '*-';
  1487.         if ident<>'*' then begin
  1488.           if not peek(['$','0'..'9']) then error(9);
  1489.           getnum;
  1490.           ident := ident + id;
  1491.         end;
  1492.       end
  1493.       else if peek(['''']) then getchar;        { character literal }
  1494.     if isbase and (base=bp) and not isidx and not (isid or isconst)
  1495.     then begin
  1496.       isconst := true; value := 0;
  1497.       ident := '$00';
  1498.       end;
  1499.     end;
  1500.     if isimmed and not (isid or isconst) then error(6);
  1501.     end; {with}
  1502.     skipblank;
  1503.   end;   {getoperand}
  1504.  
  1505.  
  1506. begin    { parse_line }
  1507.   errn := 0; labeln := 0;
  1508.   op := nul; repx := nul; lockx := false; override := lastreg;
  1509.   with op1 do begin
  1510.       isop := false; isaddr := false;
  1511.       isid := false; isreg := false; issreg := false;
  1512.       isidx := false; isbase := false;
  1513.       isbyte := false; isword := false;
  1514.       isshort := false; isnear := false; isfar := false;
  1515.       isimmed := false; isconst := false;
  1516.     end;
  1517.   op2 := op1;
  1518.   readln(src,s);                       { read in a source line }
  1519.   for p := 1 to length(s) do
  1520.     if ord(s[p]) < 32 then s[p] := ' ';
  1521.   p := 1;
  1522.   if more
  1523.   then begin
  1524.     skipblank;
  1525.     if alpha then begin
  1526.       getid;
  1527.       if test(':') then begin                               { label }
  1528.         enter(id,labeln);
  1529.         if alpha
  1530.         then getid
  1531.         else goto nocode;
  1532.         end;
  1533.       if code                                             { opcode }
  1534.       then begin
  1535.         if more and not peek([';'])
  1536.         then begin
  1537.           getoperand(op1);                               { first operand }
  1538.           if test(',')
  1539.           then begin
  1540.             if more
  1541.             then getoperand(op2)                         { second operand }
  1542.             else error(6);
  1543.             if more and not peek([';']) then error(6);
  1544.             end
  1545.           else if more and not peek([';']) then error(6);
  1546.           end
  1547.         end
  1548.         else error(4)
  1549.       end
  1550.     else
  1551. nocode: if more and not peek([';']) then error(6);
  1552.   preventry := codpnt;
  1553.   if maxavail > sizeof(codrec) shr 4 +1
  1554.   then new(codpnt)                    { create new line of intermediate code }
  1555.   else begin
  1556.     writeln; writeln('Assembly Aborted -- Out of Memory');
  1557.     close(src); close(targ); halt; end;
  1558.   if firstentry = nil then firstentry := codpnt;
  1559.   preventry^.next := codpnt;                                { and link it }
  1560.   codpnt^.next := nil;
  1561.   codpnt^.labeln := labeln;
  1562.   codpnt^.op := op;                                { enter the data }
  1563.   codpnt^.op1 := op1;
  1564.   codpnt^.op2 := op2;
  1565.   codpnt^.repx := repx;
  1566.   codpnt^.lockx := lockx;
  1567.   codpnt^.override := override;
  1568.   codpnt^.errn := errn;
  1569.   codpnt^.source := s;
  1570.   end;
  1571. end;  { parse_line }
  1572.  
  1573.  
  1574. begin  { main }
  1575.   writeln('                    InLiner'); writeln;
  1576.   startup;
  1577.   init;
  1578.   atstart := true; ok := true;
  1579.   oldlen := 0; loc := 0; tcnt := 0;
  1580.  
  1581.   pass := 1; firstentry := nil;
  1582.   while not eof(src) do parse_line;
  1583.  
  1584.   pass := 2; codpnt := firstentry; loc := 0;
  1585.   while codpnt <> nil do address;
  1586.  
  1587.   pass := 3; codpnt := firstentry; loc := 0;
  1588.   while codpnt <> nil do generate;
  1589.  
  1590.   writeln;
  1591.   if ok then writeln('Assembly Successful')
  1592.         else writeln('Assembled with Errors');
  1593.   close(src); close(targ);
  1594. end.
  1595.